home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / character.t < prev    next >
Text File  |  1990-07-10  |  8KB  |  277 lines
  1. (herald  character (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;;; Character-related routines
  27.  
  28. ;++ What should be integrated?
  29.  
  30. ;;; Very gross names. Think of better ones.  Figure out what to
  31. ;;; do about integrability.  These shouldn't be integrable if
  32. ;;; CHAR-UPCASE isn't integrable.
  33.  
  34. ;;; released procedures
  35. ;;; char<,char=,char>,charN=,char<=,char>= are primops
  36.  
  37. (lset *escape-char*            #\backslash)
  38. (lset *control-char-delimiter* #\^)
  39. (lset *dispatch-char*          #\#)
  40.  
  41. (define-integrable (lowercase? c)
  42.   (and (char>= c #\a) (char<= c #\z)))
  43.  
  44. (define-integrable (uppercase? c)
  45.   (and (char>= c #\A) (char<= c #\Z)))
  46.  
  47. (define-integrable (%char-upcase c)
  48.   (if (lowercase? c)
  49.       (ascii->char (fx- (char->ascii c) #o40))
  50.       c))
  51.  
  52. (define (char-upcase c)
  53.   (%char-upcase (enforce char? c)))
  54.  
  55. (define-integrable (%char-downcase c)
  56.   (if (uppercase? c)
  57.       (ascii->char (fx+ (char->ascii c) #o40))
  58.       c))
  59.  
  60. (define (char-downcase c)
  61.   (%char-downcase (enforce char? c)))
  62.  
  63. (define-integrable (%char-invert-case c)
  64.   (cond ((uppercase? c)
  65.          (ascii->char (fx+ (char->ascii c) #o40)))
  66.         ((lowercase? c)
  67.          (ascii->char (fx- (char->ascii c) #o40)))
  68.         (else
  69.          c)))
  70.  
  71. (define (char-invert-case c)
  72.   (%char-invert-case (enforce char? c)))
  73.  
  74. ;;; case insensitive versions of character relations
  75.  
  76. (define (char=ic c1 c2)
  77.   (char= (char-upcase c1) (char-upcase c2)))
  78.  
  79. (define (char<ic c1 c2)
  80.   (char< (char-upcase c1) (char-upcase c2)))
  81.  
  82. (define (char>ic c1 c2)
  83.   (char> (char-upcase c1) (char-upcase c2)))
  84.  
  85. (define (charn=ic c1 c2)
  86.   (charn= (char-upcase c1) (char-upcase c2)))
  87.  
  88. (define (char>=ic c1 c2)
  89.   (char>= (char-upcase c1) (char-upcase c2)))
  90.  
  91. (define (char<=ic c1 c2)
  92.   (char<= (char-upcase c1) (char-upcase c2)))
  93.  
  94. ;;; character classes, these are all predicates
  95.  
  96. (define-integrable (%alphabetic? c)
  97.   (or (lowercase? c) (uppercase? c)))
  98.  
  99. (define (alphabetic? c)
  100.   (%alphabetic? (enforce char? c)))
  101.  
  102. (define-integrable (%graphic? c)
  103.   (and (char>= c #\space) (char< c #\rubout)))
  104.  
  105. (define (graphic? c)
  106.   (%graphic? (enforce char? c)))
  107.  
  108. (define-integrable (%control? c)
  109.   (or (char< c #\space) (char= c #\rubout)))
  110.  
  111. (define (control? c)
  112.   (%control? (enforce char? c)))
  113.  
  114. (define-integrable (%numeric? c radix)
  115.   (true? (%digit c radix)))
  116.  
  117. (define (numeric? c radix)
  118.   (%numeric? c radix))
  119.  
  120. (define-integrable (%alphanumeric? c)
  121.   (or (%alphabetic? c) (%digit? c 10)))
  122.  
  123. (define (alphanumeric? c)
  124.   (%alphanumeric? (enforce char? c)))
  125.  
  126. (define (whitespace? c)
  127. ;++ Make this should be using a breakmask?
  128.   (or (char= #\space    c)
  129.       (char= #\newline  c)
  130.       (char= #\return   c)
  131.       (char= #\tab      c)
  132.       (char= #\form     c)
  133.       (char= #\linefeed c)))
  134.  
  135. ;;; random utilities
  136.  
  137. (define-integrable (%controlify c)
  138.   (ascii->char (fixnum-logand (char->ascii c) #o37)))
  139.  
  140. (define (controlify c)
  141.   (%controlify (enforce char? c)))
  142.  
  143. (define-integrable (%uncontrolify c)
  144.   (ascii->char (fx+ (char->ascii c) #o100)))
  145.  
  146. (define (uncontrolify c)
  147.   (%uncontrolify (enforce char? c)))
  148.  
  149. (define-integrable (acceptable-radix? radix)
  150.   (and (fixnum? radix) (fx> radix 0) (fx<= radix 36)))
  151.  
  152. (define (digit c radix)
  153.   (%digit (enforce char? c)
  154.           (enforce acceptable-radix? radix)))
  155.  
  156. ;++ wouldn't digit be fast enough?
  157. (define (%digit c radix)                ; for entry from reader.
  158.   (cond ((fx<= radix 10)
  159.          (cond ((and (char< c (ascii->char (fx+ (char->ascii #\0)
  160.                                                 radix)))
  161.                      (char>= c #\0))
  162.                 (fx- (char->ascii c) (char->ascii #\0)))
  163.                (else nil)))
  164.         ((and (char<= c #\9)
  165.               (char>= c #\0))
  166.          (fx- (char->ascii c) (char->ascii #\0)))
  167.         (else
  168.          (let ((cc (%char-upcase c)))
  169.            (cond ((and (char>= cc #\A)
  170.                        (char< cc (ascii->char (fx+ (char->ascii #\A)
  171.                                                    (fx- radix 10)))))
  172.                   (fx+ 10 (fx- (char->ascii cc) (char->ascii #\A))))
  173.                  (else nil))))))
  174.  
  175. (define %digit? %digit)
  176.  
  177. (define (digit? c radix) (true? (digit c radix)))
  178.  
  179. (define (char->digit c radix)
  180.   (or (digit c radix)
  181.       (char->digit (error "argument isn't a digit in given radix.~%  ~s"
  182.                           `(char->digit ,c ,radix))
  183.                    radix)))
  184.  
  185. (define %char->digit %digit)
  186.  
  187. ;;; Common Lisp calls this DIGIT-CHAR.
  188.  
  189. (define (digit->char n radix)
  190.   (let ((n     (enforce nonnegative-fixnum? n))
  191.         (radix (enforce acceptable-radix?   radix)))
  192.     (cond ((fx> n radix)
  193.            (error "argument doesn't correspond to a digit.~%  ~s"
  194.                   `(digit->char ,n ,radix)))
  195.           ((fx< n 10)
  196.            (ascii->char (fx+ (char->ascii #\0) n)))
  197.           (else
  198.            (ascii->char (fx+ (char->ascii #\A) (fx- n 10)))))))
  199.  
  200. ;;; This looks circular.  It is.
  201.  
  202. (define *symbolic-character-table*
  203.   '(
  204.     ;; System dependent options
  205.  
  206.     (newline    . #\newline)
  207.  
  208.     ;; Distinguished ASCII codes on any system
  209.  
  210.     (null       . #\null)
  211.     (bell       . #\bell)
  212.     (backspace  . #\backspace)
  213.     (tab        . #\tab)
  214.     (linefeed   . #\linefeed)
  215.     (page       . #\form)
  216.     (form       . #\form)
  217.     (formfeed   . #\form)
  218.     (return     . #\return)
  219.     (escape     . #\alt)
  220.     (altmode    . #\alt)
  221.     (alt        . #\alt)
  222.     (space      . #\space)
  223.     (rubout     . #\rubout)
  224.  
  225.     (left-paren    . #\()
  226.     (right-paren   . #\))
  227.     (star          . #\*)
  228.     (plus-sign     . #\+)
  229.     (minus-sign    . #\-)
  230.     (left-bracket  . #\[)
  231.     (right-bracket . #\])
  232.     (left-brace    . #\{)
  233.     (right-brace   . #\})
  234.     (left-angle    . #\<)
  235.     (right-angle   . #\>)
  236.     (slash         . #\/)
  237.     (backslash     . #\\)
  238.     (quote         . #\')
  239.     (backquote     . #\`)
  240.     (doublequote   . #\")
  241.     (comma         . #\,)
  242.     (dot           . #\.)
  243.     (semicolon     . #\;)
  244.     
  245.     ))
  246.  
  247. (define (char-name ch)
  248.   (car (rassq ch *symbolic-character-table*)))
  249.  
  250. (define (name-char symbol)
  251.   (cdr (assq symbol *symbolic-character-table*)))
  252.  
  253. ;;; The character handler
  254.  
  255. (define-handler char
  256.   (object nil
  257.     ((hash self) (char->ascii self))
  258.     ((display obj port) (write-char port obj))
  259.     ((print obj port)
  260.      (cond ((char= obj #\space)
  261.             (write-string port "#\\space"))
  262.            ((graphic? obj)
  263.             (write-string port "#\\")
  264.             (write-char port obj))
  265.            ((char-name obj)
  266.             => (lambda (name) (format port "#\\~s" name)))
  267.            ((control? obj)
  268.             (write-string port "#^")
  269.             (write-char port (uncontrolify obj)))
  270.            (else
  271.             (format port "#[Ascii~_~d]" (char->ascii obj)))))
  272.     ((crawl-exhibit ch)
  273.      (let ((n (char->ascii ch)))
  274.        (format (terminal-output) " ascii: decimal ~d, hex ~x, octal ~o~%"
  275.                n n n)))))
  276.                         
  277.